;;; THE VIBRATO PROBLEM: COMPARING TWO SOLUTIONS, CMJ 19(3)
;;; APPENDIX B: ACF MICROWORLD

(in-package :ACF)

;;; **********************************************************
;;; **********************************************************
;;; ACF microworld
;;; Micro-version of the Arctic, Canon, Fugue,
;;; and Nyquist transformation system
;;; (Based on Xlisp code of the Canon Score Language and
;;; the Fugue Composition Language)
;;; In Common Lisp, ©1992, Henkjan Honing

;;; **********************************************************
;;; special time variables

(defvar *start*   0 "start time")
(defvar *stretch* 1 "duration stretch factor")

;;; **********************************************************
;;; special attribute variables

(defvar *loud*      0 "amplitude scalar (additive)")
(defvar *transpose* 0 "pitch scalar (additive)")

;;; **********************************************************
;;; time transformation

(defmacro stretch (factor score)
  "Transform duration of score"
  `(let ((*stretch* (* *stretch* ,factor))) ,score))

;;; **********************************************************
;; attribute transformation constructors

(defmacro relative-transform
          (special-var operator time-fun score)
  "Make dynamic binding of special-variable"
  `(let ((,special-var
          (time-fun-compose ,operator
                            ,special-var
                            ,time-fun)))
     ,score))

;;; **********************************************************
;;; attribute transformations

(defmacro loud (increment behavior)
  "Transform amplitude of behavior"
  `(relative-transform *loud* '+ ,increment ,behavior))

(defmacro trans (increment behavior)
  "Transform pitch of behavior"
  `(relative-transform *transpose* '+ ,increment ,behavior))

;;; **********************************************************
;;; time structuring

(defmacro seq (&rest behavior)
  "Make appropriate bindings of *start*, return end-time"
  `(let* ,(mapcar #'(lambda (element)
                      (list '*start* element)) behavior)
     *start*))

(defmacro sim (&rest behavior)
  "Return end-time of simultaneous behavior"
  `(max ,@behavior))

;;; **********************************************************
;;; behaviors (procedures defining musical objects)

(defun note (pitch duration amplitude)
  "Return end-time, produce output as side-effect"
  (let ((start *start*)
        (stretched-dur (* *stretch* duration)))
    (output-note start
                 stretched-dur
                 (trans pitch *transpose*)
                 (loud amplitude *loud*))
    (+ start stretched-dur)))

(defun pause (duration)
  "Return end-time"
  (+ *start* (* *stretch* duration)))

;;; **********************************************************
;;; time function utilities

(defmacro make-time-function ((time) &body form)
  "Return a time function"
  `#'(lambda (,time) ,@form))

(defun time-funcall (time-fun-or-constant time)
  "Return result of applying time-function to time"
  (if (functionp time-fun-or-constant)
    (funcall time-fun-or-constant time)
    time-fun-or-constant))

(defun time-fun-compose (operator &rest time-funs)
  "Return time-fun composed one or more time-functions"
  (make-time-function (time)
    (apply operator
           (mapcar #'(lambda (time-fun)
                       (time-funcall time-fun time))
                   time-funs))))

(defun time-fun-+ (&rest time-funs)
  "Return added time-functions"
  (apply #'time-fun-compose #'+ time-funs))

;;; **********************************************************
;;; time function constructors

(defun ramp (from to &optional (duration 1))
  "Return a linear interpolating ramp time function"
  (let ((start *start*)
        (stretched-dur (* *stretch* duration)))
    (make-time-function (time)
      (let ((progress (/ (- time start) stretched-dur)))
        (+ from (* progress (- to from)))))))

(defun oscillator (offset frequency depth)
  "Return a sine wavetime function"
  (let ((start *start*))
    (make-time-function (time)
      (+ offset
         (* depth
            (sin (* 2 pi (- time start) frequency)))))))

;;; **********************************************************
;;; output

(defun output-note (start duration pitch amplitude)
  "Print a note with sampled attributes"
  (format t "~%[NOTE ~{~S ~}]"
          (list :start start :duration duration
                :pitch (sample pitch start duration)
                :amplitude (sample amplitude
                                   start
                                   duration))))

(defun sample (time-fun start duration
                        &optional (resolution 1/2))
  "Return list of sampled values or constant"
  (let ((samples
         (loop for count from 0.0
               to (floor (/ duration resolution))
               as time = (+ start (* count resolution))
               collect (time-funcall time-fun time))))
    (if (apply #'= samples) (first samples) samples)))

;;; **********************************************************
;;; example of use (see Figure 18)

#|

(seq (note (ramp 64 62) 1 1)
      (pause .5)
      (note (ramp 64 62) 1.5 1))
=>

[NOTE :START 0 :DURATION 1
      :PITCH (64.0 63.0 62.0) :AMPLITUDE 1 ]
[NOTE :START 1.5 :DURATION 1.5
      :PITCH (64.0 63.0 62.0 61.0) :AMPLITUDE 1 ]
3.0

|#


;;; **********************************************************
;;; **********************************************************
;;; extensions to ACF

;;; ACF time function: env (breakpoints are absolute time/value pairs)

(defmacro env (&rest breakpoints)
  "Return an interpolation expression"
  `(let* ((new-breakpoints (shift-and-stretch ',breakpoints *start* *stretch*)))
     #'(lambda(time)(interpolate new-breakpoints time))))

(defun shift-and-stretch (breakpoints shift stretch)
  "Return breakpoint-list transformed by shift and stretch"
  (mapcar #'(lambda (pair)
              (list (+ shift (* stretch (first pair)))
                    (second pair)))
          breakpoints))

(defun interpolate (breakpoints now)
  "Return inter/extrapolated value as a function of now and piece-wise-linear function"
  (let* ((from (first breakpoints))
         (to (second breakpoints))
         (from-value (second from))
         (to-value (second to))
         (from-time (first from))
         (to-time (first to)))
    (cond ((null (rest breakpoints)) from-value)
          ((<= now from-time) from-value)
          ((= now to-time) to-value)
          ((> now to-time) (interpolate (rest breakpoints) now))
          (t (let ((factor (/ (- now from-time ) (- to-time from-time))))
               (+ from-value (* factor (- to-value from-value))))))))

;;; absolute transform

(defmacro absolute-transform (special-var time-fun score)
  "Make dynamic binding of special-variable"
  `(let ((,special-var ,time-fun)) ,score))

;;; attribute transformations

(defmacro loud-abs (increment behavior)
  "Transform and shield amplitude of behavior"
  `(absolute-transform *loud* ,increment ,behavior))

(defmacro trans-abs (increment behavior)
  "Transform and shield pitch of behavior"
  `(absolute-transform *transpose* ,increment ,behavior))